perm filename TOTAL[FOO,LMM] blob
sn#092634 filedate 1974-03-17 generic text, type T, neo UTF8
(FILECREATED "16-MAR-74 7:44:05" S-TOTAL)
(LISPXPRINT (QUOTE TOTALVARS)
T)
[RPAQQ TOTALVARS
((FNS LISTFILE LISTFILES GSETQ GSET Y/N PUTPROP PRIN1L PRINT1 EDITM ?=
ED DE PRINTDESCRIPTION FIRSTATOM COPYFILE)
(USERMACROS ?= !← MAC EVAL - EF EP EV ;; LOCAL Q FV)
(ADVISE (PRINTDATE IN PRETTYDEF))
(P (/RPLACA (QUOTE ADVISEDFNS)
(REMOVE (QUOTE PRINTDATE-IN-PRETTYDEF)
ADVISEDFNS))
(SETQ LISPXMACROS (CONS (LIST (QUOTE ;)
(KWOTE (PACK)))
LISPXMACROS)))
(ADDVARS (PRETTYTYPELST (CHANGEDITMACROS USERMACROS "edit macros")
(NEWVARSLST VARS "variables")
(CHANGEDPROPLST PROP "properties")
(CHANGEDADVICELST ADVICE "advice"))
(HISTORYCOMS ;)
(LISPXCOMS ;))
(VARS (HOST)
(NEWVARSLST)
(CHANGEDITMACROS)
(CHANGEDPROPLST)
(CHANGEDADVICELST]
(DEFINEQ
(LISTFILE
[LAMBDA (LOCALFILE FOREIGNFILE LISTFILEHOST LISTFILELOGIN)
(* Calls FTP as a SUBSYS)
(BKSYSBUF
(CONCAT
"FTP
"
[SETQ LISTFILEHOST (OR LISTFILEHOST HOST (SETQ HOST
(PROGN (PRIN1 "HOST? ")
(READ T)))
(RETFROM (OR (STKPOS (QUOTE LISTFILES))
(STKPOS (QUOTE LISTFILE]
"
LOG "
(OR LISTFILELOGIN (GETP LISTFILEHOST (QUOTE LOGIN))
(AND (FMEMB LISTFILEHOST (QUOTE (SAIL SU-AI)))
(SETQ LISTFILELOGIN (SELECTQ (MKATOM (USERNAME))
(MASINTER "FOO,LMM")
(DHSMITH "1,SRI")
(CARHART "1,RC")
NIL))
(EQ (APPLY* (QUOTE Y/N)
(QUOTE Y)
(CONCAT "SAIL login as " LISTFILELOGIN "? "))
(QUOTE Y))
LISTFILELOGIN)
(PROGN (PRIN1 LISTFILEHOST T)
(RP "login {enter string⎇")))
"
TE
SE " LOCALFILE "
" (OR FOREIGNFILE
(PROGN [SETQ FOREIGNFILE
(SUBSTRING LOCALFILE
([LAMBDA (TEM)
(OR (AND (FMEMB HOST (QUOTE (SU-AI SAIL)))
(STRPOS "S-" LOCALFILE TEM NIL T T))
TEM]
(OR (STRPOS ">" LOCALFILE NIL NIL NIL T)
1))
(SUB1 (OR (STRPOS ";" LOCALFILE)
0]
(COND
((EQ (NTHCHAR FOREIGNFILE -1)
(QUOTE %.))
(GLC FOREIGNFILE)))
FOREIGNFILE))
"
DIS
QUI
QUI
"))
(KFORK (SUBSYS))
LOCALFILE])
(LISTFILES
[LAMBDA (FILLST) (* TO REDEFINE LISTFILES TO FTP
FILES ELSEWHERE)
[MAPC (OR FILLST NOTLISTEDFILES)
(FUNCTION (LAMBDA (FIL)
(LISTFILE (OR (INFILEP FIL)
(ERROR "no such file:" FIL)))
(/DSUBST NIL FIL NOTLISTEDFILES]
(SETQ NOTLISTEDFILES (/DREMOVE NIL NOTLISTEDFILES))
FILLST])
(GSETQ
[NLAMBDA (GSETVAR Y) (* Guaranteed to cause VARS to
be marked as "CHANGED")
(GSET GSETVAR (EVAL Y])
(GSET
[LAMBDA (X Y) (* Guaranteed to cause VARS to
be marked as "CHANGED")
(PROG1 (/SET X Y)
(/RPLACA (QUOTE NEWVARSLST)
(CONS X NEWVARSLST])
(Y/N
[NLAMBDA (DEFAULT MESS TYPEAHEADOKFLG)
(* Prompts for one of DEFAULT, returning the char typed, and
completing the typein. DEFAULT is an alist of
(firstchar . restchars) -
If MESS then print MESS before, and unless TYPEAHEADOKFLG is
on, clear buffers before and restore afterwards)
(PROG ((CNT (ITIMES DWIMWAIT 2))
R BUFS RSLT)
[COND
(MESS [COND
((AND (READP T)
(NOT TYPEAHEADOKFLG))
(PRIN1 BELLS T)
(DOBE)
(SETQ BUFS (CLBUFS]
(COND
((STRINGP MESS)
(PRIN1 MESS T))
(T (MAPRINT MESS T NIL "? "]
(AND (NLISTP DEFAULT)
(SETQ DEFAULT (SELECTQ DEFAULT
[Y (QUOTE ((Y . es)
(N . o]
[N (QUOTE ((N . o)
(Y . es]
NIL)))
LP (COND
[(MINUSP (SETQ CNT (SUB1 CNT)))
(PRIN1 "...")
(COND
((NLISTP DEFAULT)
(PRINT1 DEFAULT T)
(RETURN DEFAULT))
(T (PRIN1 (SETQ R (CAAR DEFAULT)))
(GO GOTIT]
((NOT (READP T))
(DISMISS 500)
(GO LP)))
RETRY
(COND
[(LISTP DEFAULT)
(SETQ R (RESETFORM (CONTROL T)
(READC T]
(T (SETQ RSLT (READ T))
(GO RETURN)))
GOTIT
(COND
((SETQ RSLT (ASSOC R DEFAULT))
(PRINT1 (CDR RSLT)
T)
(SETQ RSLT (CAR RSLT)))
((OR (EQ R (QUOTE % ))
(EQ R (QUOTE %
)))
(GO RETRY))
(T [MAPRINT DEFAULT T (COND
((NEQ R (QUOTE ?))
(QUOTE "
Please type one of: "))
(T (QUOTE "
")))
"--" ", " (FUNCTION (LAMBDA (X)
(PRIN1 (CAR X)
T)
(COND
((EQ R (QUOTE ?))
(PRIN1 (CDR X)
T]
(GO RETRY)))
RETURN
(AND BUFS (BKBUFS BUFS))
(RETURN RSLT])
(PUTPROP
[LAMBDA (NAM PROP VAL)
(* This isn't really optimal, as the best implementation
would say WHICH PROP needed dumping)
(/RPLACA (QUOTE CHANGEDPROPLST)
(CONS NAM CHANGEDPROPLST))
(/PUT NAM PROP VAL])
(PRIN1L
[LAMBDA N
(for I from 1 to N do (PRIN1 (ARG N I)
T])
(PRINT1
[LAMBDA (X FILE)
(PRIN1 X FILE)
(TERPRI FILE)
X])
(EDITM
[NLAMBDA X
(PROG ((Y USERMACROS))
(EDITL (LIST [OR (ASSOC (CAR X)
Y)
(ASSOC (CAR X)
(SETQ Y EDITMACROS))
(PROGN (LISPXPRIN1 "new macro
" T)
(CAR (SETQ Y (SETQ USERMACROS
(CONS (LIST (CAR X)
NIL)
USERMACROS]
Y)
(CDR X)
(CAR X)))
(CAAR (/RPLACA (QUOTE CHANGEDITMACROS)
(CONS (CAR X)
CHANGEDITMACROS])
(?=
[LAMBDA (FORM)
[COND
((EQ (CAR FORM)
(QUOTE STRUCFORM))
(SETQ FORM (CDR FORM]
(OR (GETD (CAR FORM))
(ERROR (CAR FORM)
"not a function" T))
(RESETFORM (PRINTLEVEL 3)
(SELECTQ (ARGTYPE (CAR FORM))
[(0 1 NIL)
(MAPC (COND
((GETD (CAR FORM))
(ARGLIST (CAR FORM)))
[(GETP (CAR FORM)
(QUOTE EXPR))
(CADR (GETP (CAR FORM)
(QUOTE EXPR]
(T (ERROR (CAR FORM)
"not a function" T)))
(FUNCTION (LAMBDA (X)
(PRIN1 X T)
(PRIN1 " = " T)
(PRINT (CAR (SETQ FORM (CDR FORM)))
T]
(PROGN (PRIN1 (ARGLIST (CAR FORM))
T)
(PRIN1 " = " T)
(PRINT (CDR FORM)
T])
(ED
[NLAMBDA X
(SETQ X (CONS (FNCHECK (CAR X)
NIL NIL T)
(CDR X)))
(PROG ((ADVISED (MEMB (CAR X)
ADVISEDFNS))
(BROKEN (MEMB (CAR X)
BROKENFNS))
TEM)
(AND (OR ADVISED BROKEN)
(VIRGINFN (CAR X)
T))
[SETQ TEM (PROG (HELPCLOCK)
(ERRORSET (CONS (QUOTE EDITF)
X)
T
(QUOTE INTERNAL]
[COND
(ADVISED (LISPXPRINT (CONS (CAR X)
(QUOTE (readvised.)))
T)
(APPLY* (QUOTE READVISE)
(CAR X]
[COND
(BROKEN (LISPXPRINT (CONS (CAR X)
(QUOTE (rebroken.)))
T)
(APPLY* (QUOTE REBREAK)
(CAR X]
(COND
(TEM (CAR TEM))
(T (ERROR!])
(DE
[NLAMBDA L
(DEFINE (LIST L])
(PRINTDESCRIPTION
[LAMBDA (FILE)
(PROG [(TEM (PACK (LIST FILE "DESCRIPTION"]
(COND
((LISTP (CAR TEM))
(PRIN1 " (RPAQQ ")
(PRIN1 TEM)
(TERPRI)
[RESETVAR PRETTYLCOM 1000
(RESETVAR **COMMENT**FLG NIL (RESETVAR FIRSTCOL 0
(RESETFORM (LINELENGTH 40)
(PRINTDEF (CAR TEM)
10 T]
(PRIN1 ")
"])
(FIRSTATOM
[LAMBDA (X)
(COND
((NLISTP X)
X)
(T (OR (FIRSTATOM (CAR X))
(FIRSTATOM (CDR X])
(COPYFILE
[LAMBDA (FROMFILE STOP START TOFILE)
(* Copies bytes from file FROMFILE to TOFILE
(or current output file) from START to STOP;
if START is not given, current FILPOS is used
(or 0 if file was not open) and STOP is assumed to be an
increment ; if STOP is not given, EOF is used -
Leaves file open)
(SETQ FROMFILE (INPUT (INFILE FROMFILE)))
(SETQ TOFILE (OUTPUT (OUTFILE TOFILE)))
(AND START (SFPTR FROMFILE START))
(ASSEMBLE NIL (* E (RADIX 10Q))
[CQ (VAG (COND
((NULL STOP)
-1)
(START (IPLUS 2 (IDIFFERENCE STOP START)))
(T (ADD1 STOP]
(PUSHN) (* BYTE COUNT)
(CQ (VAG (OPNJFN TOFILE)))
(PUSHN) (* OUT JFN)
(CQ (VAG (OPNJFN FROMFILE)))
(MOVE 5 , 1)
(POP NP , 6)
(POP NP , 4)
LP (SOJE 4 , DONE) (* DECREMENT COUNT AND JUMP IF
OUT)
(MOVE 1 , 5)
(JSYS 50Q) (* BIN)
(MOVE 3 , 2)
(JSYS 24Q) (* GTSTS -
GET STATUS)
(TLNE 2 , 1000Q) (* EOF?)
(JUMPA DONE)
(MOVE 2 , 3)
(MOVE 1 , 6)
(JSYS 51Q) (* BOUT)
(JRST LP)
DONE(CQ NIL) (* E (RADIX 10))
])
)
(ADDTOVAR USERMACROS [FV NIL (E (FREEVARS (## (ORR (UP 1)
NIL]
(LOCAL NIL (LCL TTY:))
(Q NIL (MBD QUOTE))
[EV NIL (ORR [(E (LISPXEVAL (LIST (QUOTE EDITV)
(FIRSTATOM (##)))
(QUOTE EV->]
((E (QUOTE EV?]
[EP NIL (ORR [(E (LISPXEVAL (LIST (QUOTE EDITP)
(FIRSTATOM (##)))
(QUOTE EP->]
((E (QUOTE EP?]
[?= NIL (ORR ((E (?= (##))
T))
((E (QUOTE ?=?]
(- NIL (ORR NX !NX))
[EVAL NIL (E (LISPXEVAL (## (ORR (UP 1)
NIL))
(QUOTE *]
[?= NIL (ORR [(E (MAP2C (ARGLIST (## 1))
(## 2 UP)
(FUNCTION (LAMBDA (X Y)
(PRIN1 X T)
(PRIN1 " = " T)
(PRINT Y T]
((E (QUOTE ?=?]
[EF NIL (ORR [(E (LISPXEVAL (LIST (QUOTE ED)
(FIRSTATOM (##)))
(QUOTE EF->]
((E (QUOTE EF?]
(MAC (X . Y)
(E (/RPLACA (QUOTE CHANGEDITMACROS)
(CONS (COND ((LISTP (QUOTE X))
(CAR (QUOTE X)))
(T (QUOTE X)))
CHANGEDITMACROS))
T)
(M X . Y))
(!← NIL !0))
(ADDTOVAR EDITCOMSA !← EF ?= EVAL - ?= EP EV Q LOCAL FV)
(ADDTOVAR EDITCOMSL MAC)
(DEFLIST(QUOTE(
[PRINTDATE-IN-PRETTYDEF ((PRETTYDEF . PRINTDATE)
(AFTER NIL (PRINTDESCRIPTION FILE]
))(QUOTE READVICE))
(READVISE PRINTDATE-IN-PRETTYDEF)
(/RPLACA (QUOTE ADVISEDFNS)
(REMOVE (QUOTE PRINTDATE-IN-PRETTYDEF)
ADVISEDFNS))
(SETQ LISPXMACROS (CONS (LIST (QUOTE ;)
(KWOTE (PACK)))
LISPXMACROS))
(ADDTOVAR PRETTYTYPELST (CHANGEDITMACROS USERMACROS "edit macros")
(NEWVARSLST VARS "variables")
(CHANGEDPROPLST PROP "properties")
(CHANGEDADVICELST ADVICE "advice"))
(ADDTOVAR HISTORYCOMS ;)
(ADDTOVAR LISPXCOMS ;)
(RPAQ HOST)
(RPAQ NEWVARSLST)
(RPAQ CHANGEDITMACROS)
(RPAQ CHANGEDPROPLST)
(RPAQ CHANGEDADVICELST)
STOP